home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-trace.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-04-15  |  34.6 KB  |  1,369 lines
  1. /*  $Id: pl-trace.c,v 1.41 1998/04/15 15:17:11 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: tracer
  8. */
  9.  
  10. #include "pl-incl.h"
  11. #include "pl-ctype.h"
  12.  
  13. int trace_continuation;            /* how to continue? */
  14.  
  15. #define W_PRINT        1        /* print/1 for displaying goal */
  16. #define W_WRITE        2        /* write/1 */
  17. #define W_WRITEQ    3        /* writeq/1 */
  18. #define W_DISPLAY    4        /* display/1 */
  19.  
  20. #define TRACE_FIND_NONE    0
  21. #define TRACE_FIND_ANY    1
  22. #define TRACE_FIND_NAME    2
  23. #define TRACE_FIND_TERM    3
  24.  
  25. typedef struct find_data_tag
  26. { int     port;                /* Port to find */
  27.   bool     searching;            /* Currently searching? */
  28.   int     type;                /* TRACE_FIND_* */
  29.   union
  30.   { atom_t    name;            /* Name of goal to find */
  31.     struct
  32.     { functor_t    functor;        /* functor of the goal */
  33.       Record    term;            /* Goal to find */
  34.     } term;
  35.   } goal;
  36. } find_data;
  37.  
  38. #define PrologRef(fr)     ((Word)fr - (Word)lBase)
  39. #define FrameRef(w)     ((LocalFrame)((Word)lBase + w))
  40.  
  41. #ifdef O_DEBUGGER
  42.  
  43. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  44. This module defines the tracer and interrupt  handler  that  allows  the
  45. user  to break the normal Prolog execution.  The tracer is written in C,
  46. but before taking action it calls Prolog.   This  mechanism  allows  the
  47. user to intercept and redefine the tracer.
  48. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  49.  
  50.                     /* Frame <-> Prolog integer */
  51. forwards LocalFrame    redoFrame(LocalFrame, Code *PC);
  52. forwards int        traceAction(char *, int, LocalFrame, bool);
  53. forwards void        helpTrace(void);
  54. #ifdef O_INTERRUPT
  55. forwards void        helpInterrupt(void);
  56. #endif
  57. forwards bool        hasAlternativesFrame(LocalFrame);
  58. forwards void        alternatives(LocalFrame);
  59. forwards void        listProcedure(Definition);
  60. forwards int        traceInterception(LocalFrame, LocalFrame, int, Code);
  61. forwards void        writeFrameGoal(LocalFrame frame, int how);
  62. forwards void        interruptHandler(int sig);
  63.  
  64. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  65. redoFrame() returns the latest skipped frame or NULL if  no  such  frame
  66. exists.   This  is used to give the redo port of the goal skipped rather
  67. than the redo port of some subgoal of this port.
  68. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  69.  
  70. static LocalFrame
  71. redoFrame(LocalFrame fr, Code *PC)
  72. { while( fr && false(fr, FR_SKIPPED))
  73.   { *PC = fr->programPointer;
  74.     fr = parentFrame(fr);
  75.   }
  76.  
  77.   return fr;
  78. }
  79.  
  80.  
  81. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  82. canUnifyTermWithGoal() is used to check whether the given frame satisfies
  83. the /search specification.  This function cannot use the `neat' interface
  84. as the record is not in the proper format.
  85. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  86.  
  87. static bool
  88. canUnifyTermWithGoal(LocalFrame fr)
  89. { find_data *find = LD->trace.find;
  90.  
  91.   switch(find->type)
  92.   { case TRACE_FIND_ANY:
  93.       succeed;
  94.     case TRACE_FIND_NAME:
  95.       return find->goal.name == fr->predicate->functor->name;
  96.     case TRACE_FIND_TERM:
  97.     { if ( find->goal.term.functor == fr->predicate->functor->functor )
  98.       { fid_t cid = PL_open_foreign_frame();
  99.     term_t t = PL_new_term_ref();
  100.     Word a, b;
  101.     int arity = fr->predicate->functor->arity;
  102.     int rval = TRUE;
  103.  
  104.     copyRecordToGlobal(t, find->goal.term.term);
  105.     a = valTermRef(t);
  106.     deRef(a);
  107.     a = argTermP(*a, 0);
  108.     b = argFrameP(fr, 0);
  109.     while( arity-- > 0 )
  110.     { if ( !can_unify(a++, b++) )
  111.       { rval = FALSE;
  112.         break;
  113.       }
  114.     }
  115.  
  116.     PL_discard_foreign_frame(cid);
  117.     return rval;
  118.       }
  119.  
  120.       fail;
  121.     }
  122.     default:
  123.       assert(0);
  124.       fail;
  125.   }
  126. }
  127.  
  128.  
  129. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  130. Toplevel  of  the  tracer.   This  function  is  called  from  the   WAM
  131. interpreter.   It  can  take  care of most of the tracer actions itself,
  132. except if the execution path is to  be  changed.   For  this  reason  it
  133. returns to the WAM interpreter how to continue the execution:
  134.  
  135.     ACTION_CONTINUE:    Continue normal
  136.     ACTION_FAIL:    Go to the fail port of this goal
  137.     ACTION_RETRY:    Redo the current goal
  138.     ACTION_IGNORE:    Go to the exit port of this goal
  139. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  140.  
  141. int
  142. tracePort(LocalFrame frame, LocalFrame bfr, int port, Code PC)
  143. { int OldOut;
  144.   extern int Output;
  145.   int action = ACTION_CONTINUE;
  146.   Definition def = frame->predicate;
  147.   LocalFrame fr;
  148.  
  149.   if ( (true(frame, FR_NODEBUG) && !(SYSTEM_MODE))    || /* hidden */
  150.        debugstatus.suspendTrace )               /* called back */
  151.     return ACTION_CONTINUE;
  152.  
  153.   if ( port == FAIL_PORT )
  154.     Undo(frame->mark);
  155.  
  156.                     /* trace/[1,2] */
  157.   if ( true(def, TRACE_CALL|TRACE_REDO|TRACE_EXIT|TRACE_FAIL) &&
  158.        !(port & (BREAK_PORT|CUT_PORT)) )
  159.   { char *fmt = NULL;
  160.  
  161.     switch(port)
  162.     { case CALL_PORT:
  163.     if ( true(def, TRACE_CALL) )
  164.       fmt = "T Call:  (%3ld) ";
  165.         break;
  166.       case REDO_PORT:
  167.     if ( true(def, TRACE_REDO) )
  168.       fmt = "T Redo:  (%3ld) ";
  169.         break;
  170.       case EXIT_PORT:
  171.     if ( true(def, TRACE_EXIT) )
  172.       fmt = "T Exit:  (%3ld) ";
  173.         break;
  174.       case FAIL_PORT:
  175.     if ( true(def, TRACE_FAIL) )
  176.       fmt = "T Fail:  (%3ld) ";
  177.         break;
  178.     }
  179.     if ( fmt )
  180.     { Putf(fmt, levelFrame(frame));
  181.       writeFrameGoal(frame, debugstatus.style);
  182.       Put('\n');
  183.     }
  184.   }
  185.  
  186.   if ( (port != BREAK_PORT) &&
  187.        /*(port != EXCEPTION_PORT) &&*/
  188.        ((!debugstatus.tracing &&
  189.      (false(def, SPY_ME) || (port & CUT_PORT)))    || /* non-tracing */
  190.     debugstatus.skiplevel < levelFrame(frame)    || /* skipped */
  191.     ((port & (BREAK_PORT|CUT_PORT)) &&
  192.      ((debugstatus.skiplevel == levelFrame(frame)) ||
  193.       true(def, HIDE_CHILDS)))            || /* also skipped */
  194.     false(def, TRACE_ME)                || /* non-tracing */
  195.     (!(debugstatus.visible & port))            || /* wrong port */
  196.     (port == REDO_PORT && (debugstatus.skiplevel == levelFrame(frame) ||
  197.                    (true(def, SYSTEM) && !SYSTEM_MODE)
  198.                   ))) )                   /* redos */
  199.     return ACTION_CONTINUE;
  200.  
  201. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  202. Give a trace on the skipped goal for a redo.
  203. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  204.  
  205.   { Code pc2;
  206.  
  207.     if ( port == REDO_PORT && debugstatus.skiplevel == VERY_DEEP &&
  208.      (fr = redoFrame(frame, &pc2)) != NULL )
  209.     { debugstatus.skiplevel--;                   /* avoid a loop */
  210.       switch( tracePort(fr, bfr, REDO_PORT, pc2) )
  211.       { case ACTION_CONTINUE:
  212.       if ( debugstatus.skiplevel < levelFrame(frame) )
  213.         return ACTION_CONTINUE;
  214.       break;
  215.     case ACTION_RETRY:
  216.     case ACTION_IGNORE:
  217.     case ACTION_FAIL:
  218.       Putf("Action not yet implemented here\n");
  219.       break;
  220.       }
  221.     }
  222.   }
  223.  
  224. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  225. We are in searching mode; should we actually give this port?
  226. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  227.  
  228.   if ( LD->trace.find &&  LD->trace.find->searching )
  229.   { DEBUG(2, Sdprintf("Searching\n"));
  230.  
  231.     if ( (port & LD->trace.find->port) && canUnifyTermWithGoal(frame) )
  232.     { LD->trace.find->searching = FALSE; /* Got you */
  233.     } else
  234.     { return ACTION_CONTINUE;        /* Continue the search */
  235.     }
  236.   }
  237.  
  238. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  239. Do the Prolog trace interception.
  240. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  241.  
  242.   action = traceInterception(frame, bfr, port, PC);
  243.   if ( action >= 0 )
  244.     return action;
  245.  
  246. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  247. All failed.  Things now are upto the normal Prolog tracer.
  248. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  249.  
  250.   action = ACTION_CONTINUE;
  251.   OldOut = Output;
  252.   Output = 1;
  253.  
  254. again:
  255.   Put( true(def, SPY_ME) ? '*' : ' ' );
  256.   Put( true(def, METAPRED) ? '^' : ' ');
  257.  
  258.   switch(port)
  259.   { case CALL_PORT:     Putf(" Call:  ");    break;
  260.     case REDO_PORT:     Putf(" Redo:  ");    break;
  261.     case FAIL_PORT:     Putf(" Fail:  ");    break;
  262.     case EXIT_PORT:     Putf(" Exit:  ");    break;
  263.     case UNIFY_PORT:     Putf(" Unify: ");    break;
  264.     case BREAK_PORT:     Putf(" Break: ");    break;
  265.     case EXCEPTION_PORT: Putf(" Exception: ");    break;
  266.     case CUT_CALL_PORT:     Putf(" Cut call: ");    break;
  267.     case CUT_EXIT_PORT:     Putf(" Cut exit: ");    break;
  268.   }
  269.   Putf("(%3ld) ", levelFrame(frame));
  270.   writeFrameGoal(frame, debugstatus.style);
  271.  
  272.   if (debugstatus.leashing & port)
  273.   { char buf[LINESIZ];
  274.  
  275.     debugstatus.skiplevel = VERY_DEEP;
  276.     debugstatus.tracing   = TRUE;
  277.  
  278.     Putf(" ? ");
  279.     pl_flush();
  280.     if ( GD->cmdline.notty )
  281.     { buf[0] = EOS;
  282.       readLine(buf);
  283.     } else
  284.     { buf[0] = getSingleChar();
  285.       buf[1] = EOS;
  286.       if ( isDigit(buf[0]) || buf[0] == '/' )
  287.       { Putf(buf);
  288.     readLine(buf);
  289.       }
  290.     }
  291.     if ((action = traceAction(buf, port, frame, GD->cmdline.notty ? FALSE : TRUE))
  292.                             == ACTION_AGAIN)
  293.       goto again;
  294.   } else
  295.     Put('\n');
  296.   Output = OldOut;
  297.  
  298.   return action;
  299. }
  300.  
  301.  
  302. static int
  303. setupFind(char *buf)
  304. { long rval;
  305.   char *s;
  306.   int port = 0;
  307.  
  308.   for(s = buf; *s && isBlank(*s); s++)    /* Skip blanks */
  309.     ;
  310.   if ( *s == EOS )            /* No specification: repeat */
  311.   { if ( !LD->trace.find || !LD->trace.find->port )
  312.     { Putf("[No previous search]\n");
  313.       fail;
  314.     }
  315.     LD->trace.find->searching = TRUE;
  316.     succeed;
  317.   }
  318.   for( ; *s && !isBlank(*s); s++ )    /* Parse the port specification */
  319.   { switch( *s )  
  320.     { case 'c':    port |= CALL_PORT;  continue;
  321.       case 'e':    port |= EXIT_PORT;  continue;
  322.       case 'r':    port |= REDO_PORT;  continue;
  323.       case 'f':    port |= FAIL_PORT;  continue;
  324.       case 'u':    port |= UNIFY_PORT; continue;
  325.       case 'a':    port |= CALL_PORT|REDO_PORT|FAIL_PORT|EXIT_PORT|UNIFY_PORT;
  326.                     continue;
  327.       default:  Putf("[Illegal port specification]\n");
  328.         fail;
  329.     }
  330.   }
  331.   for( ; *s && isBlank(*s); s++)    /* Skip blanks */
  332.     ;
  333.  
  334.   if ( *s == EOS )            /* Nothing is a variable */
  335.   { s = buf;
  336.     buf[0] = '_',
  337.     buf[1] = EOS;
  338.   }
  339.  
  340.   { fid_t cid = PL_open_foreign_frame();
  341.     term_t t = PL_new_term_ref();
  342.     FindData find;
  343.  
  344.     if ( !(find = LD->trace.find) )
  345.       find = LD->trace.find = allocHeap(sizeof(find_data));
  346.  
  347.     seeString(s);
  348.     rval = pl_read(t);
  349.     seenString();
  350.  
  351.     if ( rval == FALSE )
  352.     { PL_discard_foreign_frame(cid);
  353.       fail;
  354.     }
  355.  
  356.     if ( find->type == TRACE_FIND_TERM && find->goal.term.term )
  357.       freeRecord(find->goal.term.term);
  358.  
  359.     if ( PL_is_variable(t) )
  360.     { find->type = TRACE_FIND_ANY;
  361.     } else if ( PL_get_atom(t, &find->goal.name) )
  362.     { find->type = TRACE_FIND_NAME;
  363.     } else if ( PL_get_functor(t, &find->goal.term.functor) )
  364.     { find->type = TRACE_FIND_TERM;
  365.       find->goal.term.term    = compileTermToHeap(t);
  366.     } else
  367.     { Putf("[Illegal goal specification]\n");
  368.       fail;
  369.     }
  370.  
  371.     find->port      = port;
  372.     find->searching = TRUE;
  373.  
  374.     DEBUG(2, Sdprintf("setup ok, port = 0x%x, goal = ", port);
  375.       pl_write(t);
  376.       Sdprintf("\n") );
  377.  
  378.     PL_discard_foreign_frame(cid);
  379.   }
  380.  
  381.   succeed;
  382. }
  383.  
  384.  
  385. static int
  386. traceAction(char *cmd, int port, LocalFrame frame, bool interactive)
  387. { int num_arg;                /* numeric argument */
  388.   char *s;
  389.  
  390. #define FeedBack(msg)    { if (interactive) { if (cmd[1] != EOS) \
  391.                            Putf("\n"); \
  392.                          else \
  393.                            Putf(msg); } }
  394. #define Warn(msg)    { if (interactive) Putf(msg); else warning(msg); }
  395. #define Default        (-1)
  396.  
  397.   for(s=cmd; *s && isBlank(*s); s++)
  398.     ;
  399.   if ( isDigit(*s) )
  400.   { num_arg = strtol(s, &s, 10);
  401.  
  402.     while(isBlank(*s))
  403.       s++;
  404.   } else
  405.     num_arg = Default;
  406.  
  407.   switch( *s )
  408.   { case 'a':    FeedBack("abort\n");
  409.         pl_abort();
  410.     case 'b':    FeedBack("break\n");
  411.         pl_break();
  412.         return ACTION_AGAIN;
  413.     case '/':     FeedBack("/");
  414.             pl_flush();
  415.             if ( setupFind(&s[1]) )
  416.         { clear(frame, FR_SKIPPED);
  417.           return ACTION_CONTINUE;
  418.         }
  419.         return ACTION_AGAIN;            
  420.     case '.':   if ( LD->trace.find &&
  421.              LD->trace.find->type != TRACE_FIND_NONE )
  422.                   { FeedBack("repeat search\n");
  423.           LD->trace.find->searching = TRUE;
  424.           clear(frame, FR_SKIPPED);
  425.           return ACTION_CONTINUE;
  426.         } else
  427.         { Warn("No previous search\n");
  428.         }
  429.         return ACTION_AGAIN;            
  430.     case EOS:
  431.     case ' ':
  432.     case '\n':
  433.     case 'c':    FeedBack("creep\n");
  434.         clear(frame, FR_SKIPPED);
  435.         return ACTION_CONTINUE;
  436.     case '\04':
  437.     case EOF:    FeedBack("EOF: ");
  438.     case 'e':    FeedBack("exit\n");
  439.         Halt(0);
  440.     case 'f':    FeedBack("fail\n");
  441.         return ACTION_FAIL;
  442.     case 'i':    if (port & (CALL_PORT|REDO_PORT|FAIL_PORT))
  443.         { FeedBack("ignore\n");
  444.           return ACTION_IGNORE;
  445.         } else
  446.           Warn("Can't ignore goal at this port\n");
  447.         return ACTION_CONTINUE;
  448.     case 'r':    if (port & (REDO_PORT|FAIL_PORT|EXIT_PORT|EXCEPTION_PORT))
  449.         { FeedBack("retry\n[retry]\n");
  450.           return ACTION_RETRY;
  451.         } else
  452.           Warn("Can't retry at this port\n");
  453.         return ACTION_CONTINUE;
  454.     case 's':    FeedBack("skip\n");
  455.         set(frame, FR_SKIPPED);
  456.         debugstatus.skiplevel = levelFrame(frame);
  457.         return ACTION_CONTINUE;
  458.     case 'u':    FeedBack("up\n");
  459.         debugstatus.skiplevel = levelFrame(frame) - 1;
  460.         return ACTION_CONTINUE;
  461.     case 'w':    FeedBack("write\n");
  462.         debugstatus.style = W_WRITEQ;
  463.         return ACTION_AGAIN;
  464.     case 'p':    FeedBack("print\n");
  465.         debugstatus.style = W_PRINT;
  466.         return ACTION_AGAIN;
  467.     case 'd':    FeedBack("write canonical\n");
  468.         debugstatus.style = W_DISPLAY;
  469.         return ACTION_AGAIN;
  470.     case 'l':    FeedBack("leap\n");
  471.         debugstatus.tracing = FALSE;
  472.         return ACTION_CONTINUE;
  473.     case 'n':    FeedBack("no debug\n");
  474.         debugstatus.debugging = FALSE;
  475.         debugstatus.tracing = FALSE;
  476.         return ACTION_CONTINUE;
  477.     case 'g':    FeedBack("goals\n");
  478.         backTrace(frame, num_arg == Default ? 5 : num_arg);
  479.         return ACTION_AGAIN;
  480.     case 'A':    FeedBack("alternatives\n");
  481.         alternatives(frame);
  482.         return ACTION_AGAIN;
  483.     case 'C':    debugstatus.showContext = 1 - debugstatus.showContext;
  484.         if ( debugstatus.showContext == TRUE )
  485.         { FeedBack("Show context\n");
  486.         } else
  487.         { FeedBack("No show context\n");
  488.         }
  489.         return ACTION_AGAIN;
  490.     case 'L':    FeedBack("Listing");
  491.         listProcedure(frame->predicate);
  492.         return ACTION_AGAIN;
  493.     case '+':    FeedBack("spy\n");
  494.         set(frame->predicate, SPY_ME);
  495.         return ACTION_AGAIN;
  496.     case '-':    FeedBack("no spy\n");
  497.         clear(frame->predicate, SPY_ME);
  498.         return ACTION_AGAIN;
  499.     case '?': 
  500.     case 'h':    helpTrace();
  501.         return ACTION_AGAIN;
  502.     case 'D':   GD->debug_level = num_arg;
  503.         FeedBack("Debug level\n");
  504.         return ACTION_AGAIN;
  505.     default:    Warn("Unknown option (h for help)\n");
  506.         return ACTION_AGAIN;
  507.   }
  508. }
  509.  
  510. static void
  511. helpTrace(void)
  512. { Putf("Options:\n");
  513.   Putf("+:                  spy        -:                 no spy\n");
  514.   Putf("/c|e|r|f|u|a} goal: find       .:                 repeat find\n");
  515.   Putf("a:                  abort      A:                 alternatives\n");
  516.   Putf("b:                  break      c (return, space): creep\n");
  517.   Putf("d:                  display    e:                 exit\n");
  518.   Putf("f:                  fail       [depth] g:         goals\n");
  519.   Putf("h (?):              help       i:                 ignore\n");
  520.   Putf("l:                  leap       L:                 listing\n");
  521.   Putf("n:                  no debug   p:                 print\n");
  522.   Putf("r:                  retry      s:                 skip\n");
  523.   Putf("u:                  up         w:                 write\n");
  524.   Putf("C:                  toggle show context\n");
  525. #if O_DEBUG
  526.   Putf("[level] D:        set system debug level\n");
  527. #endif
  528. }
  529.  
  530. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  531. Write goal of stack frame.  First a term representing the  goal  of  the
  532. frame  is  constructed.  Trail and global stack are marked and undone to
  533. avoid garbage on the global stack.
  534.  
  535. Trick, trick, O big trick ... In order to print the  goal  we  create  a
  536. term  for  it  (otherwise  we  would  have to write a special version of
  537. write/1, etc.  for stack frames).  A small problem arises: if the  frame
  538. holds a variable we will make a reference to the new term, thus printing
  539. the wrong variable: variables sharing in a clause does not seem to share
  540. any  longer  in  the  tracer  (Anjo  Anjewierden discovered this ackward
  541. feature of the tracer).  The solution is simple: we make  the  reference
  542. pointer  the other way around.  Normally references should never go from
  543. the global to the local stack as the local stack frame  might  cease  to
  544. exists  before  the  global frame.  In this case this does not matter as
  545. the local stack frame definitely survives the tracer (measuring does not
  546. always mean influencing in computer science).
  547.  
  548. For the above reason, the code  below uses low-level manipulation rather
  549. than normal unification, etc.
  550. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  551.  
  552. static void
  553. writeFrameGoal(LocalFrame frame, int how)
  554. { Definition def = frame->predicate;
  555.   Word argv = argFrameP(frame, 0);
  556.   int argc = def->functor->arity;
  557.   int debugSave = debugstatus.debugging;
  558.   fid_t cid = PL_open_foreign_frame();
  559.   term_t goal = PL_new_term_ref();
  560.  
  561.   if ( debugstatus.showContext )
  562.     Putf("[%s] ", stringAtom(contextModule(frame)->name));
  563.   if ( def->module != MODULE_user &&
  564.        (false(def->module, SYSTEM) || SYSTEM_MODE))
  565.     Putf("%s:", stringAtom(def->module->name));
  566.  
  567.   PL_unify_functor(goal, def->functor->functor);
  568.   if ( argc > 0 )
  569.   { Word argp = valTermRef(goal);
  570.     int i;
  571.  
  572.     deRef(argp);
  573.     argp = argTermP(*argp, 0);
  574.  
  575.     for(i=0; i<argc; i++)
  576.     { Word a;
  577.  
  578.       deRef2(argv+i, a);
  579.       *argp++ = (isVar(*a) ? makeRef(a) : *a);
  580.     }
  581.   }
  582.   
  583.   switch(how)
  584.   { case W_PRINT:
  585.     debugstatus.debugging = FALSE;
  586.     if ( GD->bootsession )
  587.       pl_write(goal);
  588.     else
  589.       pl_print(goal);
  590.     debugstatus.debugging = debugSave;
  591.     break;
  592.     case W_WRITE:
  593.     pl_write(goal);
  594.     break;
  595.     case W_WRITEQ:
  596.     pl_writeq(goal);
  597.     break;
  598.     case W_DISPLAY:
  599.     pl_write_canonical(goal);
  600.     break;
  601.   }
  602.  
  603.   PL_discard_foreign_frame(cid);
  604. }
  605.  
  606. /*  Write those frames on the stack that have alternatives left.
  607.  
  608.  ** Tue May 10 23:23:11 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  609.  
  610. static void
  611. alternatives(LocalFrame frame)
  612. { for(; frame; frame = frame->backtrackFrame)
  613.   { if (hasAlternativesFrame(frame) &&
  614.      (false(frame, FR_NODEBUG) || SYSTEM_MODE) )
  615.     { Putf("    [%3ld] ", levelFrame(frame));
  616.       writeFrameGoal(frame, debugstatus.style);
  617.       Put('\n');
  618.     }
  619.   }
  620. }    
  621.  
  622.  
  623. static void
  624. listProcedure(Definition def)
  625. { fid_t cid = PL_open_foreign_frame();
  626.   qid_t qid;
  627.   extern int Output;
  628.   int OldOut = Output;
  629.   term_t argv = PL_new_term_refs(1);
  630.   Procedure proc = lookupProcedure(FUNCTOR_listing1, MODULE_system);
  631.  
  632.   unify_definition(argv, def, 0, 0);    /* module:name(args) */
  633.   Output = 1;
  634.   qid = PL_open_query(MODULE_user, PL_Q_NODEBUG, proc, argv);
  635.   PL_next_solution(qid);
  636.   PL_close_query(qid);
  637.   Output = OldOut;
  638.   PL_discard_foreign_frame(cid);
  639. }
  640.  
  641.  
  642. void
  643. backTrace(LocalFrame frame, int depth)
  644. { extern int Output;
  645.   int OldOut = Output;
  646.   LocalFrame same_proc_frame = NULL;
  647.   Definition def = NULL;
  648.   int same_proc = 0;
  649.   int alien = FALSE;
  650.  
  651.   if ( frame == NULL )
  652.      frame = environment_frame;
  653.  
  654.   Output = 1;
  655.   for(; depth > 0 && frame;
  656.         alien = (frame->parent == NULL), frame = parentFrame(frame))
  657.   { if ( alien )
  658.       Putf("    <Alien goal>\n");
  659.  
  660.     if ( frame->predicate == def )
  661.     { if ( ++same_proc >= 10 )
  662.       { if ( same_proc == 10 )
  663.       Putf("    ...\n    ...\n");
  664.     same_proc_frame = frame;  
  665.     continue;
  666.       }
  667.     } else
  668.     { if ( same_proc_frame != NULL )
  669.       { if ( false(same_proc_frame, FR_NODEBUG) || SYSTEM_MODE )
  670.         { Putf("    [%3ld] ", levelFrame(same_proc_frame));
  671.       writeFrameGoal(same_proc_frame, debugstatus.style);
  672.       depth--;
  673.       Put('\n');
  674.     }
  675.     same_proc_frame = NULL;
  676.     same_proc = 0;
  677.       }
  678.       def = frame->predicate;
  679.     }
  680.  
  681.     if (false(frame, FR_NODEBUG) || SYSTEM_MODE)
  682.     { Putf("    [%3ld] ", levelFrame(frame));
  683.       writeFrameGoal(frame, debugstatus.style);
  684.       depth--;
  685.       Put('\n');
  686.     }
  687.   }
  688.   Output = OldOut;
  689. }
  690.  
  691. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  692. Trace interception mechanism.  Whenever the tracer wants to perform some
  693. action   it   will   first   call   the    users'    Prolog    predicate
  694. prolog_trace_interception/4, allowing the user to define his/her action.
  695. If  this procedure succeeds the tracer assumes the trace action has been
  696. done and returns, otherwise the  default  C-defined  trace  actions  are
  697. performed.
  698.  
  699. This predicate is supposed to return one of the following atoms:
  700.  
  701.     continue            simply continue (creep)
  702.     fail                fail this goal
  703.     retry                retry this goal
  704.     ignore                pretend this call succeeded
  705. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  706.  
  707. static int
  708. traceInterception(LocalFrame frame, LocalFrame bfr, int port, Code PC)
  709. { int rval = -1;            /* Default C-action */
  710.   predicate_t proc;
  711.  
  712.   proc = _PL_predicate("prolog_trace_interception", 4, "user",
  713.                &GD->procedures.prolog_trace_interception4);
  714.   if ( !proc->definition->definition.clauses )
  715.     return rval;
  716.  
  717.   if ( !GD->bootsession && GD->debug_level == 0 )
  718.   { fid_t cid = PL_open_foreign_frame();
  719.     qid_t qid;
  720.     term_t argv = PL_new_term_refs(4);
  721.     term_t rarg = argv+3;
  722.     atom_t portname = NULL_ATOM;
  723.     functor_t portfunc = 0;
  724.     int nodebug = FALSE;
  725.  
  726.     switch(port)
  727.     { case CALL_PORT:       portname = ATOM_call;         break;
  728.       case REDO_PORT:       portname = ATOM_redo;         break;
  729.       case EXIT_PORT:       portname = ATOM_exit;         break;
  730.       case FAIL_PORT:       portname = ATOM_fail;         break;
  731.       case UNIFY_PORT:       portname = ATOM_unify;     break;
  732.       case EXCEPTION_PORT: portname = ATOM_exception;      break;
  733.       case BREAK_PORT:     portfunc = FUNCTOR_break1;     break;
  734.       case CUT_CALL_PORT:  portfunc = FUNCTOR_cut_call1; break;
  735.       case CUT_EXIT_PORT:  portfunc = FUNCTOR_cut_exit1; break;
  736.       default:
  737.     assert(0);
  738.         return rval;
  739.     }
  740.  
  741.     if ( portname )
  742.       PL_put_atom(argv, portname);
  743.     else
  744.     { int pcn;
  745.  
  746.       if ( PC && false(frame->predicate, FOREIGN) && frame->clause )
  747.     pcn = PC - frame->clause->clause->codes;
  748.       else
  749.     pcn = 0;
  750.  
  751.       PL_unify_term(argv,
  752.             PL_FUNCTOR, portfunc,
  753.             PL_INTEGER, pcn);
  754.     }
  755.  
  756.     PL_put_integer(argv+1, PrologRef(frame));
  757.     PL_put_integer(argv+2, PrologRef(bfr));
  758.     PL_put_variable(rarg);
  759.  
  760.     qid = PL_open_query(MODULE_user, PL_Q_NODEBUG, proc, argv);
  761.     if ( PL_next_solution(qid) )
  762.     { atom_t a;
  763.  
  764.       if ( PL_get_atom(rarg, &a) )
  765.       { if ( a == ATOM_continue )
  766.       rval = ACTION_CONTINUE;
  767.     else if ( a == ATOM_nodebug )
  768.     { rval = ACTION_CONTINUE;
  769.       nodebug = TRUE;
  770.     } else if ( a == ATOM_fail )
  771.       rval = ACTION_FAIL;
  772.     else if ( a == ATOM_retry )
  773.       rval = ACTION_RETRY;
  774.     else if ( a == ATOM_ignore )
  775.       rval = ACTION_IGNORE;
  776.       } else if ( PL_is_functor(rarg, FUNCTOR_retry1) )
  777.       { long w;
  778.     term_t arg = PL_new_term_ref();
  779.  
  780.     if ( PL_get_arg(1, rarg, arg) && PL_get_long(arg, &w) )
  781.     { debugstatus.retryFrame = FrameRef(w);
  782.       rval = ACTION_RETRY;
  783.     } else
  784.       warning("prolog_trace_interception/3: bad argument to retry/1");
  785.       }
  786.     }
  787.     PL_close_query(qid);
  788.     PL_discard_foreign_frame(cid);
  789.  
  790.     if ( nodebug )
  791.       pl_nodebug();
  792.  
  793.   }
  794.  
  795.   return rval;
  796. }
  797.  
  798. #endif /*O_DEBUGGER*/
  799.  
  800. static bool
  801. hasAlternativesFrame(register LocalFrame frame)
  802. { ClauseRef cref;
  803.  
  804.   if ( true(frame, FR_CUT) )
  805.     fail;
  806.   if (true(frame->predicate, FOREIGN))
  807.     succeed;
  808.   for(cref = frame->clause; cref; cref = cref->next)
  809.     if ( false(cref->clause, ERASED) )
  810.       succeed;
  811.   fail;
  812. }
  813.  
  814. word
  815. pl_trace_continuation(term_t what)
  816. { return PL_get_integer(what, &trace_continuation);
  817. }
  818.  
  819. void
  820. resetTracer(void)
  821. {
  822. #ifdef O_INTERRUPT
  823. #if defined(HAVE_SIGACTION) && defined(SA_RESTART) && defined(SA_NOMASK)
  824.   struct sigaction set;
  825.  
  826.   memset(&set, 0, sizeof(set));
  827.   set.sa_handler = interruptHandler;
  828.   set.sa_flags   = SA_RESTART|SA_NOMASK;
  829.  
  830.   sigaction(SIGINT, &set, NULL);
  831. #else
  832. #ifdef HAVE_SIGSET
  833.   sigset(SIGINT, interruptHandler);
  834. #else
  835. #ifndef BSD_SIGNALS
  836. #define REINSTATE_INTERRUPT_HANDLER
  837. #endif
  838.   signal(SIGINT, interruptHandler);
  839. #endif
  840. #endif
  841. #endif
  842.  
  843.   debugstatus.tracing      =
  844.   debugstatus.debugging    = FALSE;
  845.   debugstatus.suspendTrace = FALSE;
  846.   debugstatus.skiplevel    = 0;
  847.   debugstatus.retryFrame   = NULL;
  848. }
  849.  
  850.  
  851. #ifdef O_INTERRUPT
  852.  
  853. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  854. Handling  interrupts.   We  know  we  are  not  in  critical  code  (see
  855. startCritical()  and endCritical(), so the heap is consistent.  The only
  856. problem can be that we are currently writing the arguments of  the  next
  857. goal  above  the  local  stack  top  pointer.  To avoid problems we just
  858. increment the top pointer to point above the furthest argument.
  859. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  860.  
  861. static void
  862. helpInterrupt(void)
  863. { Putf("Options:\n");
  864.   Putf("a:                 abort      b:                 break\n");
  865.   Putf("c:                 continue   e:                 exit\n");
  866. #ifdef O_DEBUGGER
  867.   Putf("g:                 goals      t:                 trace\n");
  868. #endif
  869.   Putf("h (?):             help\n");
  870.  
  871. }
  872.  
  873. static void
  874. interruptHandler(int sig)
  875. { extern int Output;
  876.   int OldOut = Output;
  877.   LocalFrame oldltop = lTop;
  878.   Char c; 
  879.  
  880.   if ( !GD->initialised )
  881.   { Sfprintf(Serror, "Interrupt during startup. Cannot continue\n");
  882.     Halt(1);
  883.   }  
  884.  
  885.   Output = 1;
  886.   gc_status.blocked++;
  887. #if O_SHIFT_STACKS
  888.   shift_status.blocked++;
  889. #endif
  890.   lTop = (LocalFrame)addPointer(lTop, sizeof(struct localFrame) +
  891.                       MAXARITY * sizeof(word));
  892. again:
  893.   Putf("\nAction (h for help) ? ");
  894.   pl_flush();
  895.   ResetTty();                           /* clear pending input -- atoenne -- */
  896.   c = getSingleChar();
  897.  
  898. #ifdef REINSTATE_INTERRUPT_HANDLER
  899. #ifdef SIG_ACK
  900.   signal(SIGINT, SIG_ACK);
  901. #else
  902.   signal(SIGINT, interruptHandler);    /* reinsert handler */
  903. #endif
  904. #endif
  905.  
  906. #if defined(SIG_UNBLOCK)
  907. { sigset_t set;
  908.  
  909.   sigemptyset(&set);
  910.   sigaddset(&set, SIGINT);
  911.   sigprocmask(SIG_UNBLOCK, &set, NULL);
  912. }
  913. #endif
  914.  
  915.   switch(c)
  916.   { case 'a':    Putf("abort\n");
  917.         pl_abort();
  918.         break;
  919.     case 'b':    Putf("break\n");
  920.         pl_break();
  921.         goto again;        
  922.     case 'c':    Putf("continue\n");
  923.         break;
  924.     case 04:
  925.     case EOF:    Putf("EOF: ");
  926.     case 'e':    Putf("exit\n");
  927.         Halt(0);
  928.         break;
  929. #ifdef O_DEBUGGER
  930.     case 'g':    Putf("goals\n");
  931.         backTrace(environment_frame, 5);
  932.         goto again;
  933. #endif /*O_DEBUGGER*/
  934.     case 'h':
  935.     case '?':    helpInterrupt();
  936.         goto again;
  937. #ifdef O_DEBUGGER
  938.     case 't':    Putf("trace\n");
  939.         pl_trace();
  940.         break;
  941. #endif /*O_DEBUGGER*/
  942.     default:    Putf("Unknown option (h for help)\n");
  943.         goto again;
  944.   }
  945. #if O_SHIFT_STACKS
  946.   shift_status.blocked--;
  947. #endif
  948.   gc_status.blocked--;
  949.   Output = OldOut;
  950.   lTop = oldltop;
  951. }
  952.  
  953. #endif /*O_INTERRUPT*/
  954.  
  955.  
  956. void
  957. PL_interrupt(int sig)
  958. {
  959. #ifdef O_INTERRUPT
  960.    interruptHandler(sig);
  961. #endif
  962. }
  963.  
  964.  
  965. void
  966. initTracer(void)
  967. { debugstatus.visible      = 
  968.   debugstatus.leashing     = CALL_PORT|FAIL_PORT|REDO_PORT|EXIT_PORT|
  969.                  BREAK_PORT|EXCEPTION_PORT;
  970.   debugstatus.style        = GD->bootsession ? W_WRITE : W_PRINT; 
  971.   debugstatus.showContext  = FALSE;
  972.  
  973.   resetTracer();
  974. }
  975.  
  976.         /********************************
  977.         *       PROLOG PREDICATES       *
  978.         *********************************/
  979.  
  980. #if O_DEBUGGER
  981.  
  982. int
  983. tracemode(int doit, int *old)
  984. { if ( doit )
  985.     doit = TRUE;
  986.  
  987.   if ( old )
  988.     *old = debugstatus.tracing;
  989.  
  990.   if ( debugstatus.tracing != doit )
  991.   { if ( doit )
  992.     { debugstatus.debugging = TRUE;
  993.       debugstatus.skiplevel = VERY_DEEP;
  994.       if ( LD->trace.find )
  995.     LD->trace.find->searching = FALSE;
  996.     }
  997.     debugstatus.tracing = doit;
  998.     callEventHook(PLEV_TRACING, doit);
  999.   }
  1000.  
  1001.   succeed;
  1002. }
  1003.  
  1004.  
  1005. int
  1006. debugmode(int doit, int *old)
  1007. { if ( doit )
  1008.     doit = TRUE;
  1009.  
  1010.   if ( old )
  1011.     *old = debugstatus.debugging;
  1012.  
  1013.   if ( debugstatus.debugging != doit )
  1014.   { if ( doit )
  1015.       debugstatus.skiplevel = VERY_DEEP;
  1016.     debugstatus.debugging = doit;
  1017.     callEventHook(PLEV_DEBUGGING, doit);
  1018.   }
  1019.  
  1020.   succeed;
  1021. }
  1022.  
  1023. #else /*O_DEBUGGER*/
  1024.  
  1025. int
  1026. tracemode(int doit, int *old)
  1027. { succeed;
  1028. }
  1029.  
  1030. int
  1031. debugmode(int doit, int *old)
  1032. { succeed;
  1033. }
  1034.  
  1035. #endif
  1036.  
  1037. word
  1038. pl_trace()
  1039. { return tracemode(TRUE, NULL);
  1040. }
  1041.  
  1042. word
  1043. pl_notrace()
  1044. { return tracemode(FALSE, NULL);
  1045. }
  1046.  
  1047. word
  1048. pl_tracing()
  1049. { return debugstatus.tracing;
  1050. }
  1051.  
  1052. word
  1053. pl_debug()
  1054. { return debugmode(TRUE, NULL);
  1055. }
  1056.  
  1057. word
  1058. pl_nodebug()
  1059. { tracemode(FALSE, NULL);
  1060.   debugmode(FALSE, NULL);
  1061.  
  1062.   succeed;
  1063. }
  1064.  
  1065. word
  1066. pl_debugging()
  1067. { return debugstatus.debugging;
  1068. }
  1069.  
  1070. word
  1071. pl_skip_level(term_t old, term_t new)
  1072. { atom_t a;
  1073.   long sl;
  1074.  
  1075.   if ( debugstatus.skiplevel == VERY_DEEP )
  1076.   { TRY(PL_unify_atom(old, ATOM_very_deep));
  1077.   } else
  1078.   { TRY(PL_unify_integer(old, debugstatus.skiplevel));
  1079.   }
  1080.       
  1081.   if ( PL_get_long(new, &sl) )
  1082.   { debugstatus.skiplevel = (unsigned long) sl;
  1083.     succeed;
  1084.   }
  1085.   if ( PL_get_atom(new, &a) && a == ATOM_very_deep)
  1086.   { debugstatus.skiplevel = VERY_DEEP;
  1087.     succeed;
  1088.   }
  1089.  
  1090.   fail;
  1091. }
  1092.  
  1093. word
  1094. pl_spy(term_t p)
  1095. { Procedure proc;
  1096.  
  1097.   if ( get_procedure(p, &proc, 0, GP_FIND) )
  1098.   { set(proc->definition, SPY_ME);
  1099.     return pl_debug();
  1100.   }
  1101.  
  1102.   fail;
  1103. }
  1104.  
  1105. word
  1106. pl_nospy(term_t p)
  1107. { Procedure proc;
  1108.  
  1109.   if ( get_procedure(p, &proc, 0, GP_FIND) )
  1110.   { clear(proc->definition, SPY_ME);
  1111.     succeed;
  1112.   }
  1113.  
  1114.   fail;
  1115. }
  1116.  
  1117. word
  1118. pl_leash(term_t old, term_t new)
  1119. { return setInteger(&debugstatus.leashing, "$leash", old, new);
  1120. }
  1121.  
  1122. word
  1123. pl_visible(term_t old, term_t new)
  1124. { return setInteger(&debugstatus.visible, "$visible", old, new);
  1125. }
  1126.  
  1127.  
  1128. word
  1129. pl_debuglevel(term_t old, term_t new)
  1130. { return setInteger(&GD->debug_level, "$debuglevel", old, new);
  1131. }
  1132.  
  1133.  
  1134.  
  1135. word
  1136. pl_unknown(term_t old, term_t new)
  1137. { Module m = contextModule(environment_frame);
  1138.   atom_t a = (true(m, UNKNOWN) ? ATOM_trace : ATOM_fail);
  1139.  
  1140.   if ( !PL_unify_atom(old, a) )
  1141.     fail;
  1142.   if ( PL_get_atom(new, &a) )
  1143.   { if ( a == ATOM_fail ) 
  1144.     { clear(m, UNKNOWN);
  1145.       succeed;
  1146.     } else if ( a == ATOM_trace )
  1147.     { set(m, UNKNOWN);
  1148.       succeed;
  1149.     }
  1150.   }
  1151.   
  1152.   return warning("unknown/2: instantiation fault");
  1153. }
  1154.  
  1155.  
  1156. word
  1157. pl_prolog_current_frame(term_t frame)
  1158. { LocalFrame fr = environment_frame;
  1159.  
  1160.   if ( fr->predicate->definition.function == pl_prolog_current_frame )
  1161.     fr = parentFrame(fr);        /* thats me! */
  1162.  
  1163.   return PL_unify_integer(frame, PrologRef(fr));
  1164. }
  1165.  
  1166.  
  1167. word
  1168. pl_prolog_frame_attribute(term_t frame, term_t what,
  1169.               term_t value)
  1170. { LocalFrame fr;
  1171.   atom_t key;
  1172.   int arity;
  1173.   term_t result = PL_new_term_ref();
  1174.   long fri;
  1175.  
  1176.   if ( !PL_get_long(frame, &fri) ||
  1177.        !PL_get_name_arity(what, &key, &arity) )
  1178.   { ierr:
  1179.     return warning("prolog_frame_attribute/3: instantiation fault");
  1180.   }
  1181.  
  1182.   if ((fr = FrameRef(fri)) < lBase || fr > lTop)
  1183.     return warning("prolog_frame_attribute/3: illegal frame reference");
  1184.  
  1185.   set(fr, FR_WATCHED);            /* explicit call to do this? */
  1186.  
  1187.   if ( key == ATOM_argument && arity == 1 )
  1188.   { term_t arg = PL_new_term_ref();
  1189.     int argn;
  1190.     Word p = valTermRef(value);
  1191.  
  1192.     if ( !PL_get_arg(1, what, arg) || !PL_get_integer(arg, &argn) || argn < 1 )
  1193.       goto ierr;
  1194.  
  1195.     if ( true(fr->predicate, FOREIGN) || !fr->clause )
  1196.     { if ( argn > fr->predicate->functor->arity )
  1197.     fail;
  1198.     } else
  1199.     { if ( argn > fr->clause->clause->prolog_vars )
  1200.     fail;
  1201.     }
  1202.  
  1203. #ifdef O_DEBUGLOCAL            /* see pl-wam.c */
  1204.     assert( *argFrameP(fr, argn-1) != (word)(((char*)ATOM_nil) + 1) );
  1205.     checkData(argFrameP(fr, argn-1));
  1206. #endif
  1207.  
  1208.    deRef(p);
  1209.    if ( isVar(*p) )
  1210.    { *p = makeRef(argFrameP(fr, argn-1));
  1211.      DoTrail(p);
  1212.      succeed;
  1213.    }
  1214.  
  1215.    fail;
  1216.   }
  1217.   if ( arity != 0 )
  1218.     goto ierr;
  1219.  
  1220.   if (        key == ATOM_level)
  1221.   { PL_put_integer(result, levelFrame(fr));
  1222.   } else if (key == ATOM_has_alternatives)
  1223.   { PL_put_atom(result, hasAlternativesFrame(fr) ? ATOM_true : ATOM_false);
  1224.   } else if (key == ATOM_alternative)
  1225.   { if (fr->backtrackFrame == (LocalFrame) NULL)
  1226.       fail;
  1227.     PL_put_integer(result, PrologRef(fr->backtrackFrame));
  1228.   } else if (key == ATOM_parent)
  1229.   { LocalFrame parent;
  1230.  
  1231.     if ( fr->parent )
  1232.       clearUninitialisedVarsFrame(fr->parent, fr->programPointer);
  1233.  
  1234.     if ( (parent = parentFrame(fr)) )
  1235.       PL_put_integer(result, PrologRef(parent));
  1236.     else
  1237.       fail;
  1238.   } else if (key == ATOM_top)
  1239.   { PL_put_atom(result, fr->parent ? ATOM_false : ATOM_true);
  1240.   } else if (key == ATOM_context_module)
  1241.   { PL_put_atom(result, contextModule(fr)->name);
  1242.   } else if (key == ATOM_clause)
  1243.   { if ( false(fr->predicate, FOREIGN) && fr->clause )
  1244.       PL_put_pointer(result, fr->clause->clause);
  1245.     else
  1246.       fail;
  1247.   } else if (key == ATOM_goal)
  1248.   { int arity, n;
  1249.     term_t arg = PL_new_term_ref();
  1250.     
  1251.     if (fr->predicate->module != MODULE_user)
  1252.     { PL_put_functor(result, FUNCTOR_module2);
  1253.       PL_get_arg(1, result, arg);
  1254.       PL_unify_atom(arg, fr->predicate->module->name);
  1255.       PL_get_arg(2, result, arg);
  1256.     } else
  1257.       PL_put_term(arg, result);
  1258.  
  1259.     if ((arity = fr->predicate->functor->arity) == 0)
  1260.     { PL_unify_atom(arg, fr->predicate->functor->name);
  1261.     } else
  1262.     { term_t a = PL_new_term_ref();
  1263.  
  1264.       PL_unify_functor(arg, fr->predicate->functor->functor);
  1265.       for(n=0; n < arity; n++)
  1266.       { PL_get_arg(n+1, arg, a);
  1267.     unify_ptrs(valTermRef(a), argFrameP(fr, n));
  1268.       }
  1269.     }
  1270.   } else if ( key == ATOM_pc )
  1271.   { if ( fr->programPointer &&
  1272.      fr->parent &&
  1273.      false(fr->parent->predicate, FOREIGN) )
  1274.       PL_put_integer(result,
  1275.              fr->programPointer - fr->parent->clause->clause->codes);
  1276.     else
  1277.       fail;
  1278.   } else if ( key == ATOM_hidden )
  1279.   { atom_t a;
  1280.  
  1281.     if ( SYSTEM_MODE )
  1282.     { a = ATOM_true;
  1283.     } else
  1284.     { if ( true(fr, FR_NODEBUG) || false(fr->predicate, TRACE_ME) )
  1285.     a = ATOM_true;
  1286.       else
  1287.     a = ATOM_false;
  1288.     }
  1289.  
  1290.     PL_put_atom(result, a);
  1291.   } else
  1292.     return warning("prolog_frame_attribute/3: unknown key");
  1293.  
  1294.   return PL_unify(value, result);
  1295. }
  1296.  
  1297.  
  1298. #if O_DEBUGGER
  1299.  
  1300.          /*******************************
  1301.          *      PROLOG EVENT HOOK    *
  1302.          *******************************/
  1303.  
  1304. void
  1305. callEventHook(int ev, ...)
  1306. { if ( !PROCEDURE_event_hook1 )
  1307.     PROCEDURE_event_hook1 = PL_predicate("prolog_event_hook", 1, "user");
  1308.   
  1309.   if ( PROCEDURE_event_hook1->definition->definition.clauses )
  1310.   { va_list args;
  1311.     fid_t fid = PL_open_foreign_frame();
  1312.     term_t arg = PL_new_term_ref();
  1313.  
  1314.     va_start(args, ev);
  1315.     switch(ev)
  1316.     { case PLEV_ERASED:
  1317.       {    void *ptr = va_arg(args, void *);     /* object erased */
  1318.  
  1319.     PL_unify_term(arg, PL_FUNCTOR, FUNCTOR_erased1,
  1320.                    PL_POINTER, ptr);
  1321.     break;
  1322.       }
  1323.       case PLEV_DEBUGGING:
  1324.       { int dbg = va_arg(args, int);
  1325.     
  1326.     PL_unify_term(arg, PL_FUNCTOR, FUNCTOR_debugging1,
  1327.                PL_ATOM, dbg ? ATOM_true : ATOM_false);
  1328.     break;
  1329.       }
  1330.       case PLEV_TRACING:
  1331.       { int trc = va_arg(args, int);
  1332.     
  1333.     PL_unify_term(arg, PL_FUNCTOR, FUNCTOR_tracing1,
  1334.                PL_ATOM, trc ? ATOM_true : ATOM_false);
  1335.     break;
  1336.       }
  1337.       case PLEV_BREAK:
  1338.       case PLEV_NOBREAK:
  1339.       { Clause clause = va_arg(args, Clause);
  1340.     int offset = va_arg(args, int);
  1341.  
  1342.     PL_unify_term(arg, PL_FUNCTOR, FUNCTOR_break3,
  1343.                    PL_POINTER, clause,
  1344.                    PL_INTEGER, offset,
  1345.                PL_ATOM, ev == PLEV_BREAK ? ATOM_true
  1346.                                  : ATOM_false);
  1347.     break;
  1348.       }
  1349.       case PLEV_FRAMEFINISHED:
  1350.       { LocalFrame fr = va_arg(args, LocalFrame);
  1351.  
  1352.     PL_unify_term(arg, PL_FUNCTOR, FUNCTOR_frame_finished1,
  1353.                    PL_INTEGER, PrologRef(fr));
  1354.     break;
  1355.       }
  1356.       default:
  1357.     warning("callEventHook(): unknown event: %d", ev);
  1358.         goto out;
  1359.     }
  1360.     
  1361.     PL_call_predicate(MODULE_user, FALSE, PROCEDURE_event_hook1, arg);
  1362.   out:
  1363.     PL_discard_foreign_frame(fid);
  1364.     va_end(args);
  1365.   }
  1366. }
  1367.  
  1368. #endif /*O_DEBUGGER*/
  1369.